Attribute VB_Name = "Metaprogramming"
'begin_line
'close
'open
'begin_path
'end_line
'stroke_colour
'fill_colour
'stroke_width
'begin_group
'end_group


Enum efill_type
    e_no_fill = 0
    e_colour_fill = 1
    e_postscript_fill = 2
End Enum

Sub import_colour(ts, r As Integer, g As Integer, b As Integer)
    Dim str As String
    Dim pos As Integer
            
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    
    pos = InStr(1, str, Chr(9))
    r = Val(Left(str, pos))
    
    str = Mid(str, pos + 1)
    pos = InStr(1, str, Chr(9))
    g = Val(Left(str, pos))
    
    b = Val(Mid(str, pos + 1))
End Sub

Sub import_postscript(ts, i As String, parameters() As Integer)
    Dim str As String
    Dim pos As Integer
            
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    
    pos = InStr(1, str, Chr(9))
    i = Left(str, pos - 1)
    For ii = 0 To 4
        str = Mid(str, pos + 1)
        pos = InStr(1, str, Chr(9))
        parameters(ii) = Val(Left(str, pos))
    Next ii
    
    parameters(5) = Val(Mid(str, pos + 1))
End Sub

Function import_float(ts) As Double
    Dim str As String
    Do While 1
        str = ts.ReadLine
        If Left(str, 1) <> "#" Then
            Exit Do
        End If
    Loop
    import_float = CDbl(str)
End Function

Function import_lines(ts, scaling As Double) As Shape

    Dim sub_path_closed As Boolean
    sub_path_closed = False
    Dim sub_path_created As Boolean
    sub_path_created = False
    Dim count_segments As Integer
    count_segments = 0
    
    Dim crv As Curve
    Set crv = Application.CreateCurve(ActiveDocument)
    
   
    Dim sp As SubPath


    Dim str As String
    Do While ts.atendofstream <> True
        str = ts.ReadLine
        
        'begin_path
        '   not necessary for first path
        'comments
        If Left(str, 1) = "#" Then
        
        ElseIf str = "begin_new_path" Then
            If sub_path_created Then
                sp.Closed = sub_path_closed
                sub_path_created = False
            End If
        'close
        '   path is closed
        ElseIf str = "path_is_closed" Then
            sub_path_closed = True
        'open
        '   path is closed
        ElseIf str = "path_is_open" Then
            sub_path_closed = False
        'end_line
        ElseIf str = "end_line" Then
            Exit Do
        
        ' data
        Else
            pos = InStr(1, str, Chr(9))
            X = Val(Left(str, pos)) * scaling
            Y = Val(Mid(str, pos + 1)) * scaling
            If Not sub_path_created Then
                Set sp = crv.CreateSubPath(X, Y)
            Else
                sp.AppendLineSegment X, Y, False
            End If
            sub_path_created = True
                
        End If
    Loop
    sp.Closed = sub_path_closed
    Dim s As Shape
    Set s = ActiveLayer.CreateCurve(crv)
    Set import_lines = s
End Function


Sub Import_meta_data(FileName As String)
    
    ' get scale factor (1.0 = lesser of page dimensions)
    ActiveDocument.Unit = cdrMillimeter
    Dim ap As Page
    Dim scale_x As Double, scale_y As Double
    ActivePage.GetSize scale_x, scale_y
    Dim scaling As Double
    If scale_x < scale_y Then
        scaling = scale_x
    Else
        scaling = scale_y
    End If
    
    Dim postscript_fill_name As String
    
    Dim postscript_fill_parameters(5) As Integer
    
    
    ' stroke colour defaults to black
    Dim stroke_r As Integer, stroke_g As Integer, stroke_b As Integer
    stroke_r = 0
    stroke_g = 0
    stroke_b = 0
    
    ' fill colour defaults to white
    Dim fill_r As Integer, fill_g As Integer, fill_b As Integer
    fill_r = 255
    fill_g = 255
    fill_b = 255
    Dim fill_type As Integer
    fill_type = e_colour_fill
    Dim no_stroke As Boolean
    no_stroke = False
    
    ' outline width default
    Dim stroke_width As Double
    stroke_width = 0.0005
    
    'text stream
    Dim fs, f, ts
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(FileName)
    Set ts = f.OpenAsTextStream(1, -2)
    
    Dim sr As New ShapeRange
    Dim curr_shape As Shape
    
    Dim str
    Do While ts.atendofstream <> True
        str = ts.ReadLine
        
       
        'comments
        If Left(str, 1) = "#" Then
        
        ' stroke_colour
        ElseIf str = "stroke_colour" Then
            import_colour ts, stroke_r, stroke_g, stroke_b
            no_stroke = False
            'MsgBox ("stroke_colour:" & stroke_r & ":" & stroke_g & ":" & stroke_b)
        
        ' fill colour
        ElseIf str = "fill_colour" Then
            import_colour ts, fill_r, fill_g, fill_b
            fill_type = e_colour_fill
            'MsgBox ("fill_colour:" & fill_r & ":" & fill_g & ":" & fill_b)
        
        ElseIf str = "fill_postscript" Then
            import_postscript ts, postscript_fill_name, postscript_fill_parameters
            'MsgBox "postscript index " & postscript_fill_index
            'For ii = 0 To 4
            '    MsgBox "postscript parameter(" & ii & ") = " & postscript_fill_parameters(ii)
            'Next ii
            fill_type = e_postscript_fill
            
        ' no_fill
        ElseIf str = "no_fill" Then
            fill_type = e_no_fill
        
        ' no_stroke
        ElseIf str = "no_stroke" Then
            no_stroke = True
            'MsgBox ("fill_colour:" & fill_r & ":" & fill_g & ":" & fill_b)
        
        ' stroke width
        ElseIf str = "stroke_width" Then
            stroke_width = import_float(ts)
            'MsgBox ("stroke_width:" & stroke_width)
            
        ' lines
        ElseIf str = "begin_line" Then
            Set curr_shape = import_lines(ts, scaling)
            If fill_type = e_no_fill Then
                curr_shape.Fill.ApplyNoFill
            ElseIf fill_type = e_colour_fill Then
                curr_shape.Fill.UniformColor.RGBAssign fill_r, fill_g, fill_b
            ElseIf fill_type = e_postscript_fill Then
                Dim pf As PostScriptFill
                Set pf = curr_shape.Fill.ApplyPostscriptFill(postscript_fill_name)
                For ii = 0 To 4
                    pf.Properties(ii + 1) = postscript_fill_parameters(ii)
                Next ii
            End If
            If no_stroke Then
                curr_shape.Outline.Type = cdrNoOutline
            Else
                curr_shape.Outline.color.RGBAssign stroke_r, stroke_g, stroke_b
            End If
            curr_shape.Outline.Width = stroke_width
            sr.Add curr_shape
            'MsgBox ("lines:")
        
        ' begin group
        ElseIf str = "begin_group" Then
            sr.RemoveAll
            'MsgBox ("begin group")
        
        ' end group
        ElseIf str = "end_group" Then
            sr.AddToSelection
            Set curr_shape = Application.ActiveSelection.Group
            curr_shape.RemoveFromSelection
            'MsgBox ("end group")
        Else
            MsgBox (str)
            Error 11
        End If
    Loop
End Sub
    
    
Sub import_meta_commands()
    'd_meta_file.efile_name = "c:\cdr.test.delete.this"
    d_meta_file.Show
    

    Import_meta_data (d_meta_file.efile_name)
End Sub

Sub print_fill_parameters()
    Dim curr_fill As PostScriptFill
    Set curr_fill = Application.ActiveSelection.Fill.PostScript
    MsgBox curr_fill.Name & " #" & curr_fill.Index
    MsgBox "#1 = " & curr_fill.Properties(1)
    MsgBox "#2 = " & curr_fill.Properties(2)
    MsgBox "#3 = " & curr_fill.Properties(3)
    MsgBox "#4 = " & curr_fill.Properties(4)
    MsgBox "#5 = " & curr_fill.Properties(5)
End Sub
